home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / outline-window.lisp / outline-window.lisp
Encoding:
Text File  |  1992-09-08  |  24.3 KB  |  665 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; outline-window.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines a Finder-like hierarchy display. Outline-window instances display
  10. hierarchies.
  11.  
  12.  
  13. ==== To use this file ====
  14. (Note: Generic functions specify the interface.)
  15.  
  16. This file defines the outline-node and outline-window classes which enable
  17. viewing hierarchies. See the examples at the bottom for their use.
  18.  
  19.  
  20. ================================================================
  21. Status =========================================================
  22. ================================================================
  23. Usable.
  24.  
  25. To Do:
  26. - Convert outline-window to outline-fred-mixin (use
  27. :scrolling-fred-dialog-item) !
  28. - Test with circular and repeating objects.
  29.  
  30. Bugs:
  31. * Define (setf on-root-outline-window) :after to update the display.
  32. - Doesn't remember whether a node was previously expanded when re-expanding it.
  33. √- Expanding or collapsing a selected node causes part of the node's line to
  34. be selected.
  35. √- Collapsing a node that contains expanded children doesn't collapse
  36. children.
  37. √* Clicking in scroll bar doesn't scroll. Will go away when I switch to
  38. dialog-items.
  39.  
  40. ================================================================
  41. Change history =================================================
  42. ================================================================
  43. 25-Aug-92 mc    Created.
  44. 07-Sep-92 mc    Finished and started testing.
  45.  
  46. |#
  47.  
  48.  
  49. (in-package "CCL")
  50.  
  51. (export '(OUTLINE-NODE
  52.           OBJECT-OUTLINE-NODE
  53.           F-SORT-CHILDREN
  54.           OUTLINE-WINDOW
  55.           F-OUTLINE-NODE-SELECTED-OW
  56.           ON-ROOT-OUTLINE-WINDOW
  57.           EXPAND-OUTLINE-NODE-OW
  58.           COLLAPSE-OUTLINE-NODE-OW)
  59.         "CCL")
  60.  
  61.  
  62. (require "F-PT-IN-SCROLL" "CCL:UMASS Utils;f-pt-in-scroll")
  63.  
  64.  
  65. ;;;================================================================
  66. ;;; Define the outline-node class and methods.
  67. ;;;================================================================
  68.  
  69. (defclass outline-node ()
  70.   ((object
  71.     :accessor object-outline-node
  72.     :initarg :object
  73.     :type t
  74.     :documentation "The object this node displays.")
  75.    (int-level
  76.     :accessor int-level-outline-node
  77.     :initarg :int-level
  78.     :type fixnum
  79.     :documentation "This node's level. Zero is the root.")
  80.    (on-parent
  81.     :accessor on-parent-outline-node
  82.     :initarg :on-parent
  83.     :initform nil
  84.     :type outline-node
  85.     :documentation "This node's parent node. Multiple inheritance is not
  86. supported.")
  87.    (l-on-children
  88.     :accessor l-on-children-outline-node
  89.     :initarg :l-on-children
  90.     :initform ()
  91.     :type list
  92.     :documentation "This node's children nodes. Children are computed and
  93. saved as necessary, i.e. when the node is expanded.")
  94.    (f-children-computed
  95.     :accessor f-children-computed-outline-node
  96.     :initarg :f-children-computed
  97.     :initform nil
  98.     :type t
  99.     :documentation "A flag that is non-nil if this node's children are
  100. cached in l-on-children-outline-node .")
  101.    (f-expanded
  102.     :accessor f-expanded-outline-node
  103.     :initarg :f-expanded
  104.     :initform nil
  105.     :type t
  106.     :documentation "A flag that is non-nil if this node's children are
  107. displayed.")
  108.    ;;
  109.    (mark-line-start
  110.     :accessor mark-line-start-outline-node
  111.     :initarg :mark-line-start
  112.     :type buffer-mark
  113.     :documentation "A FRED buffer mark in an outline-window's fred-buffer
  114. that marks the start of this object's line.")
  115.    )
  116.   (:documentation "A class that holds objects in a hierarchy for the
  117. outline view."))
  118.  
  119.  
  120. (defgeneric object-outline-node (outline-node)
  121.   (:documentation "Returns the object outline-node represents."))
  122.  
  123.  
  124. (defmethod initialize-instance :before ((outline-node outline-node)
  125.                                       &key object)
  126.   (declare (optimize speed))
  127.   ;;
  128.  (check-type object (not null)))
  129.  
  130.  
  131. (defmethod initialize-instance :after ((outline-node outline-node) &key)
  132.   "Sets outline-node's int-level-outline-node to 1+ its parent's, if
  133. non-nil. Otherwise sets it to zero."
  134.   (declare (optimize speed))
  135.   ;;
  136.   (setf (int-level-outline-node outline-node)
  137.         (if (on-parent-outline-node outline-node)
  138.           (1+ (int-level-outline-node (on-parent-outline-node outline-node)))
  139.           0)))
  140.  
  141.  
  142. (defmethod compute-children-if-necessary ((outline-node outline-node)
  143.                                           (fn-l-children-outline-window function))
  144.   "Computes outline-node's children if necessary, setting their parents to
  145. outline-node. Fn-l-children-outline-window is a function that takes an
  146. object as its only argument and returns a list of objects that are the
  147. passed object's children."
  148.   (declare (optimize speed))
  149.   ;;
  150.   (unless (f-children-computed-outline-node outline-node)
  151.     (setf (l-on-children-outline-node outline-node)
  152.           (loop for object-child in (funcall fn-l-children-outline-window
  153.                                              (object-outline-node outline-node))
  154.                 for object-node-child = (make-instance 'outline-node
  155.                                           :object object-child
  156.                                           :on-parent outline-node)
  157.                 collect object-node-child)
  158.           (f-children-computed-outline-node outline-node) t)))
  159.  
  160.  
  161. (defmethod expand-outline-node ((outline-node outline-node)
  162.                                 (fn-l-children-outline-window function))
  163.   "Calls compute-children-if-necessary then sets f-expanded-outline-node to t."
  164.   (declare (optimize speed))
  165.   ;;
  166.   (compute-children-if-necessary outline-node fn-l-children-outline-window)
  167.   (setf (f-expanded-outline-node outline-node) t))
  168.  
  169.  
  170. (defmethod collapse-outline-node ((outline-node outline-node))
  171.   "Sets f-expanded-outline-node to nil."
  172.   (declare (optimize speed))
  173.   ;;
  174.   (setf (f-expanded-outline-node outline-node) nil))
  175.  
  176.  
  177. ;;;================================================================
  178. ;;; Define the outline-window class and methods.
  179. ;;;================================================================
  180.  
  181. (defclass outline-window (fred-window)
  182.   ((on-root
  183.     :accessor on-root-outline-window
  184.     :initarg :on-root
  185.     :type outline-node
  186.     :documentation "The root object's node of this window.")
  187.    (int-indent
  188.     :accessor int-indent-outline-window
  189.     :initarg :int-indent
  190.     :initform 5
  191.     :type fixnum
  192.     :documentation "The number of characters to indent each level.")
  193.    (fn-l-children
  194.     :accessor fn-l-children-outline-window
  195.     :initarg :fn-l-children
  196.     :type function
  197.     :documentation "A function of one argument (an object) that returns a
  198. list of children objects. Used to expand nodes.")
  199.    (fn-str-object
  200.     :accessor fn-str-object-outline-window
  201.     :initarg :fn-str-object
  202.     :type function
  203.     :documentation "A function of one argument (an object) that returns a
  204. string representing the object. The default is #'str-format-object .")
  205.    (outline-node-selected
  206.     :accessor f-outline-node-selected-ow
  207.     :type (or null outline-node)
  208.     :initform nil
  209.     :documentation "The outline node currently selected or nil if none is.")
  210.    (l-outline-node
  211.     :accessor l-outline-node-ow
  212.     :initarg :l-outline-node
  213.     :initform ()
  214.     :type list
  215.     :documentation "A list of all displayed outline-nodes. Used by
  216. object-node-from-int-line-start .")
  217.    (f-sort-children
  218.     :accessor f-sort-children-outline-window
  219.     :initarg :f-sort-children
  220.     :initform t
  221.     :type t
  222.     :documentation "A flag that, when non-nil, causes
  223. expand-outline-node-ow to sort the expanded children.")
  224.    )
  225.   (:documentation "A class that holds objects in a hierarchy for the
  226. outline view.")
  227.   (:default-initargs
  228.     :window-title "Outline"
  229.     :view-font '("Monaco" 9)))
  230.  
  231.  
  232. (defmethod initialize-instance ((outline-window outline-window)
  233.                               &rest plist-init-args
  234.                               &key root-object fn-l-children fn-str-object)
  235.   (declare (optimize speed))
  236.   ;;
  237.   (check-type root-object (not null))
  238.   (check-type fn-l-children function)
  239.   ;;
  240.   ;; On-root's buffer is set when the object's text is inserted:
  241.   ;;
  242.   (let ((on-root (make-instance 'outline-node :object root-object :on-parent nil)))
  243.     (apply #'call-next-method             ;do the usual
  244.            outline-window
  245.            :on-root on-root
  246.            :l-outline-node (list on-root)
  247.            :fn-str-object (or fn-str-object #'str-format-object)
  248.            plist-init-args)
  249.   ;;
  250.   (let ((buffer (fred-buffer outline-window)))
  251.     (ccl::%buffer-set-read-only buffer t)
  252.     (fred-update outline-window)        ;shows the ® in the title
  253.     ))
  254.   ;;
  255.   ;; Without-interrupts keeps clicks from happening during expansion, which
  256.   ;;  causes "> Error: Slot MARK-LINE-START is unbound in #<OUTLINE-NODE #xC259F1>"
  257.   ;;
  258.   (without-interrupts
  259.    (insert-text-outline-node-ow (on-root-outline-window outline-window)
  260.                                 outline-window 0)
  261.    (expand-outline-node-ow (on-root-outline-window outline-window)
  262.                            outline-window)))
  263.  
  264.  
  265. ;;;================================================================
  266. ;;; Define mcl methods.
  267. ;;;================================================================
  268.  
  269. (defmethod window-can-do-operation ((outline-window outline-window)
  270.                                      sym-op &optional menu-item)
  271.   "Returns nil for all operations, which makes the Edit menu items inactive."
  272.   (declare (optimize speed)
  273.            (ignore sym-op menu-item))
  274.   ;;
  275.   nil)
  276.  
  277.  
  278. (defmethod view-default-position ((outline-window outline-window))
  279.   #@(3 41))
  280.  
  281.  
  282. (defmethod view-default-size ((outline-window outline-window))
  283.   #@(212 180))
  284.  
  285.  
  286. (defmethod view-key-event-handler ((outline-window outline-window)
  287.                                     (character character))
  288.   "Disallows cursor movement, because such movement deselects but doesn't
  289. update the selected object."
  290.   ;;
  291.   ;; Fix: Allow arrow characters to do expand, contract, move up, down, etc.
  292.   ;;
  293.   (ed-beep))
  294.  
  295.  
  296. (defmethod window-needs-saving-p ((outline-window outline-window))
  297.   ;;
  298.   nil)
  299.  
  300.  
  301. (defmethod window-update-cursor ((outline-window outline-window)
  302.                                   (pt-where integer))
  303.   "Changes the cursor: If pt-where is above an outline arrow then makes it
  304. *plus-cursor*; otherwise makes it *arrow-cursor* ."
  305.   (declare (ignore pt-where))
  306.   ;;
  307.   ;; Fix!
  308.   ;;
  309.   (set-cursor *arrow-cursor*))
  310.  
  311.  
  312. (defmethod view-click-event-handler ((outline-window outline-window)
  313.                                      (pt-where fixnum))
  314.   "Selects the line corresponding to pt-where."
  315.   (declare (optimize speed))
  316.   ;;
  317.   (if (f-pt-in-scroll outline-window pt-where)
  318.     (call-next-method)
  319.     (do-outline-click outline-window pt-where)))
  320.  
  321.  
  322. (defmethod do-outline-click ((outline-window outline-window)
  323.                             (pt-where fixnum))
  324.   (declare (optimize speed))
  325.   ;;
  326.   (let* ((buffer (fred-buffer outline-window))
  327.          (int-buffer-pos-click (fred-point-position outline-window pt-where))
  328.          (int-line-start (buffer-line-start buffer int-buffer-pos-click))
  329.          (int-line-end (buffer-line-end buffer int-buffer-pos-click))
  330.          (clicked-on-object-node (object-node-from-int-line-start
  331.                                   outline-window int-line-start))
  332.          (f-object-node-arrow (f-on-arrow-pt outline-window pt-where)))
  333.     ;;
  334.     ;; If they clicked on an arrow then track until they release and do the
  335.     ;;  arrow operation only if they released on the arrow (in addition to
  336.     ;;  having clicked on it). This is proper Mac interface style.
  337.     ;;
  338.     (when f-object-node-arrow
  339.       (loop ;do (track-mouse-above-arrow f-object-node-arrow outline-window)
  340.             while (#_StillDown)
  341.             finally (let ((f-object-node-arrow-new
  342.                            (f-on-arrow-pt outline-window
  343.                                           (view-mouse-position outline-window))))
  344.                       (unless (eq f-object-node-arrow-new
  345.                                   f-object-node-arrow)
  346.                         (setf f-object-node-arrow nil)))))
  347.     ;;
  348.     (cond ((and f-object-node-arrow
  349.                 (f-expanded-outline-node f-object-node-arrow))
  350.            (collapse-outline-node-ow f-object-node-arrow outline-window)
  351.            (collapse-selection outline-window t)
  352.            (setf (f-outline-node-selected-ow outline-window) nil))
  353.           ((and f-object-node-arrow
  354.                 (not (f-expanded-outline-node f-object-node-arrow)))
  355.            (expand-outline-node-ow f-object-node-arrow outline-window)
  356.            (collapse-selection outline-window t)
  357.            (setf (f-outline-node-selected-ow outline-window) nil))
  358.           (clicked-on-object-node
  359.            (set-selection-range outline-window int-line-start int-line-end)
  360.            (setf (f-outline-node-selected-ow outline-window)
  361.                  clicked-on-object-node))
  362.           (t
  363.            (collapse-selection outline-window t)
  364.            (setf (f-outline-node-selected-ow outline-window) nil)))
  365.     (fred-update outline-window)))
  366.  
  367.  
  368. ;;;================================================================
  369. ;;; Define methods for selected objects.
  370. ;;;================================================================
  371.  
  372. (defgeneric f-outline-node-selected-ow (outline-window)
  373.   (:documentation "Returns the object currently selected in outline-window
  374. or nil if none are selected."))
  375.  
  376.  
  377. ;;;================================================================
  378. ;;; Define functions for expanding and collapsing nodes.
  379. ;;;================================================================
  380.  
  381. (defgeneric expand-outline-node-ow (outline-node outline-window)
  382.   (:documentation "Expands outline-node in outline-window, and updates the
  383. display."))
  384.  
  385.  
  386. (defmethod expand-outline-node-ow ((outline-node outline-node)
  387.                                    (outline-window outline-window))
  388.   (declare (optimize speed))
  389.   ;;
  390.   (unless (f-expanded-outline-node outline-node)
  391.     ;;
  392.     ;; Expand outline-node and insert lines for each of its children,
  393.     ;;  respecting each's indent level.
  394.     ;;
  395.     (expand-outline-node outline-node (fn-l-children-outline-window outline-window))
  396.     (setf (l-outline-node-ow outline-window)
  397.           (append (l-outline-node-ow outline-window)
  398.                   (l-on-children-outline-node outline-node)))
  399.     (update-arrow-outline-node-ow outline-node outline-window)
  400.     (loop with outline-node-prev = outline-node
  401.           for outline-node-child in
  402.           (if (f-sort-children-outline-window outline-window)
  403.             (sort (copy-list (l-on-children-outline-node outline-node))
  404.                   #'string<
  405.                   :key #'(lambda (outline-node)
  406.                            (funcall (fn-str-object-outline-window outline-window)
  407.                                     (object-outline-node outline-node))))
  408.             (l-on-children-outline-node outline-node))
  409.           for buffer-prev = (mark-line-start-outline-node outline-node-prev)
  410.           for int-line-start = (buffer-line-start
  411.                                 buffer-prev
  412.                                 (buffer-position buffer-prev)1)
  413.           do (progn
  414.                (insert-text-outline-node-ow outline-node-child outline-window
  415.                                             int-line-start)
  416.                (setf outline-node-prev outline-node-child)))
  417.     (fred-update outline-window)))
  418.  
  419.  
  420. (defgeneric collapse-outline-node-ow (outline-node outline-window)
  421.   (:documentation "Expands outline-node in outline-window, and updates the
  422. display."))
  423.  
  424.  
  425. (defmethod collapse-outline-node-ow ((outline-node outline-node)
  426.                                     (outline-window outline-window))
  427.   (declare (optimize speed))
  428.   ;;
  429.   (when (f-expanded-outline-node outline-node)
  430.     ;;
  431.     ;; Collapse outline-node and collapse and delete each of its children.
  432.     ;;
  433.     (setf (l-outline-node-ow outline-window)
  434.           (set-difference (l-outline-node-ow outline-window)
  435.                           (l-on-children-outline-node outline-node)))
  436.     (collapse-outline-node outline-node)
  437.     (update-arrow-outline-node-ow outline-node outline-window)
  438.     (loop for outline-node-child in (l-on-children-outline-node outline-node)
  439.           do (progn
  440.                (collapse-outline-node-ow outline-node-child outline-window)
  441.                (delete-text-outline-node-ow outline-node-child outline-window)))
  442.     (fred-update outline-window)))
  443.  
  444.  
  445. ;;;================================================================
  446. ;;; Define support functions.
  447. ;;;================================================================
  448.  
  449. (defun str-format-object (object)
  450.   "Returns object's ~A format string."
  451.   (declare (optimize speed))
  452.   ;;
  453.   (format nil "~A" object))
  454.  
  455.  
  456. (defmethod object-node-from-int-line-start ((outline-window outline-window) 
  457.                                            (int-line-start fixnum))
  458.   "Returns the outline-node whose mark-line-start-outline-node equals
  459. int-line-start ."
  460.   (declare (optimize speed))
  461.   ;;
  462.   (loop for outline-node in (l-outline-node-ow outline-window)
  463.         for buffer = (mark-line-start-outline-node outline-node)
  464.         for int-line-start-node = (buffer-position buffer)
  465.         when (= int-line-start-node int-line-start)
  466.         do (return outline-node)        ;exits before finally clause, if found
  467.         finally (return nil)))
  468.  
  469.  
  470. (defmethod insert-text-outline-node-ow ((outline-node outline-node)
  471.                                        (outline-window outline-window)
  472.                                        (int-line-start fixnum))
  473.   "Inserts in outline-window's fred-buffer outline-node's text, and sets
  474. outline-node's mark-line-start-outline-node to be the line just inserted
  475. at."
  476.   (declare (optimize speed))
  477.   ;;
  478.   (let* ((buffer (fred-buffer outline-window))
  479.          (str-object (funcall (fn-str-object-outline-window outline-window)
  480.                               (object-outline-node outline-node)))
  481.          (int-indent (int-indent-outline-window outline-window))
  482.          (int-level (int-level-outline-node outline-node))
  483.          (str-object-indented
  484.           (concatenate 'string
  485.                        (make-string (* int-indent (1+ int-level))
  486.                                     :initial-element #\Space)
  487.                        str-object
  488.                        (string #\Return))))
  489.     (ccl::%buffer-set-read-only buffer nil)
  490.     (buffer-insert buffer str-object-indented int-line-start)
  491.     ;; Make the mark *after* the insert so that it doesn't move on us.
  492.     (setf (mark-line-start-outline-node outline-node)
  493.           (make-mark (fred-buffer outline-window) int-line-start))
  494.     (ccl::%buffer-set-read-only buffer t)
  495.     (update-arrow-outline-node-ow outline-node outline-window)))
  496.  
  497.  
  498. (defmethod delete-text-outline-node-ow ((outline-node outline-node)
  499.                                        (outline-window outline-window))
  500.   "Deletes from outline-window's fred-buffer outline-node's text."
  501.   (declare (optimize speed))
  502.   ;;
  503.   (let* ((buffer (mark-line-start-outline-node outline-node))
  504.          (int-start (buffer-position buffer))
  505.          (int-end (1+ (buffer-line-end buffer))))       ;1+ gets the #\Return
  506.     (ccl::%buffer-set-read-only buffer nil)
  507.     (buffer-delete (fred-buffer outline-window) int-start int-end)
  508.     (ccl::%buffer-set-read-only buffer t)))
  509.  
  510.  
  511. ;;;================================================================
  512. ;;; Define functions for handling arrows.
  513. ;;;================================================================
  514.  
  515. (defmethod update-arrow-outline-node-ow ((outline-node outline-node)
  516.                                          (outline-window outline-window))
  517.   "Inserts the proper arrow icon at column 1 of the outline-node's line."
  518.   (declare (optimize speed))
  519.   ;;
  520.   ;; Compute children so we know if outline-node has any. We must know this
  521.   ;;  because no arrows are drawn for childless nodes.
  522.   ;;
  523.   (compute-children-if-necessary outline-node
  524.                                  (fn-l-children-outline-window outline-window))
  525.   ;;
  526.   (let* ((font-spec-old (view-font outline-window))
  527.          (font-spec-arrow font-spec-old)
  528.          ;(font-spec-arrow '("Symbol" :outline))
  529.          (buffer (mark-line-start-outline-node outline-node))
  530.          (int-buffer-pos (buffer-position buffer))
  531.          (string-arrow (cond ((null (l-on-children-outline-node outline-node))
  532.                               " ")
  533.                              ;; Following two arrows are in the Symbol font:
  534.                              ((f-expanded-outline-node outline-node)
  535.                               ;"Ø"       ;symbol
  536.                               "+")
  537.                              (t
  538.                               ;"Æ"       ;symbol
  539.                               "-"))))
  540.     (ccl::%buffer-set-read-only buffer nil)
  541.     (buffer-delete buffer int-buffer-pos (1+ int-buffer-pos))
  542.     (buffer-set-font-spec buffer font-spec-arrow)
  543.     ;; This insert increments buffer's position so we correct it back afterwards:
  544.     (buffer-insert buffer string-arrow)
  545.     (set-mark buffer int-buffer-pos)
  546.     ;;
  547.     (buffer-set-font-spec buffer font-spec-old)
  548.     (ccl::%buffer-set-read-only buffer t)
  549.     (fred-update outline-window)))
  550.  
  551.  
  552. (defmethod f-on-arrow-pt ((outline-window outline-window) (pt-where fixnum))
  553.   "Returns the outline-node clicked on if pt-where is on its corresponding
  554. arrow. Returns nil otherwise."
  555.   (declare (optimize speed))
  556.   ;;
  557.   (let* ((int-buffer-pos-click (fred-point-position outline-window pt-where))
  558.          (buffer (fred-buffer outline-window))
  559.          (int-line-start (buffer-line-start buffer int-buffer-pos-click))
  560.          (clicked-on-object-node (object-node-from-int-line-start
  561.                                   outline-window int-line-start)))
  562.     (if (and clicked-on-object-node
  563.              ;; The or allows for slop.
  564.              (or (= int-buffer-pos-click int-line-start)
  565.                  (= int-buffer-pos-click (1+ int-line-start))))
  566.       clicked-on-object-node
  567.       nil)))
  568.  
  569.  
  570. ;;;
  571. ;;; Done.
  572. ;;;
  573.  
  574. (provide "OUTLINE-WINDOW")
  575.  
  576.  
  577. #| ;;; Define some testing functions.
  578.  
  579. (defun test-ow1 ()
  580.   "Makes an outline-window that displays this simple symbol hierarchy:
  581.   a - b - d
  582.     \
  583.       c - e
  584.         \
  585.           f  "
  586.   (declare (optimize speed))
  587.   ;;
  588.   (make-instance 'outline-window
  589.     :window-title "Simple Outline"
  590.     :f-sort-children nil
  591.     :root-object 'a
  592.     :fn-l-children #'(lambda (sym-object)
  593.                        (case sym-object
  594.                          (a '(b c))
  595.                          (b '(d))
  596.                          (c '(e f))
  597.                          (t ())))))
  598.  
  599.  
  600. ;;;
  601. ;;; Define a class for viewing CLOS instance hierarchies.
  602. ;;;
  603.  
  604. (defclass class-outline-window (outline-window)
  605.   ()                                    ;no new slots
  606.   (:documentation "A subclass of outline-window whose instances show the
  607. CLOS class hierarchy, print classes nicely, and print documentation on
  608. double-clicks.")
  609.   (:default-initargs
  610.     :view-size #@(256 313)
  611.     :int-indent 3
  612.     :fn-l-children #'class-direct-subclasses
  613.     :fn-str-object #'(lambda (class)
  614.                        (substitute
  615.                         #\Space #\-
  616.                         (format nil "~:(~A~)" (class-name class))))))
  617.  
  618.  
  619. (defmethod initialize-instance :after ((class-outline-window class-outline-window)
  620.                                      &key root-object)
  621.   (declare (optimize speed))
  622.   ;;
  623.   (set-window-title class-outline-window
  624.                     (format nil "~:(~A~) Hierarchy" (class-name root-object))))
  625.  
  626.  
  627. (defmethod view-click-event-handler :after ((class-outline-window class-outline-window)
  628.                                             (pt-where fixnum))
  629.   "Prints the selected object's documentation if it's non-nil and there
  630. was a double-click. Edits the definition if the command and option keys
  631. were down."
  632.   ;;
  633.   (let* ((f-outline-node-sel (f-outline-node-selected-ow class-outline-window))
  634.          (class (and f-outline-node-sel
  635.                      (object-outline-node f-outline-node-sel)))
  636.          (str-doc (and class
  637.                        (or (documentation class)
  638.                            (documentation (class-name class) 'class)))))
  639.     (when (and class
  640.                (double-click-p)
  641.                str-doc)
  642.       (format t "~&~A: ~A" class (substitute #\Space #\Return str-doc)))
  643.     (when (and class
  644.                (command-key-p)
  645.                (option-key-p))
  646.       (edit-definition (class-name class)))))
  647.  
  648.  
  649. (defun test-ow2 ()
  650.   "Makes an outline-window that displays the CLOS hierarchy. Double click
  651. on 'Outline Node' to get documentation (few other classes are documented)."
  652.   (declare (optimize speed))
  653.   ;;
  654.   (make-instance 'class-outline-window
  655.     :root-object (find-class 'standard-object)))
  656.  
  657.  
  658. (defun test-ow3 ()
  659.   "Makes an outline-window that displays MCL's simple-view hierarchy."
  660.   (declare (optimize speed))
  661.   ;;
  662.   (make-instance 'class-outline-window
  663.     :root-object (find-class 'simple-view)))
  664.  
  665. |#